;; Christopher Jackson <christopher.jackson@gmail.com>
;; September 15, 2010
;; Evolutionary Computatation
;; nqueens.lisp

(defparameter *population* nil) ;; steady-state population
(defparameter *N* 16)            ;; size of the board (NxN)
(defparameter *population-size* 3) ;; 5 means 1680 individuals
(defparameter *mutation-rate* 0.8) ;; 80% mutation rate

(defclass individual ()
  ((genotype
    :initarg :genotype
    :initform nil
    :accessor genotype
    :documentation "The genotype of this individual")
   (fitness
    :initarg :fitness
    :initform nil
    :accessor fitness
    :documentation "fitness of the individual")
   (crossover
    :initarg :crossover
    :initform nil
    :accessor crossover
    :documentation "A list of crossover operations performed on this individual")
   (mutation
    :initarg :mutation
    :initform nil
    :accessor mutation
    :documentation "A list of mutation operations performed on this individual")
   (rank
    :initarg :rank
    :initform nil
    :accessor rank
    :documentation "Set and used only during Parent Selection or Survivor selection")))

(defun main ()
  (let ((parents nil)
	(children nil))
    (initialize-population)
    (do ((iterations 0 (1+ iterations))
	 (best (first *population*) (best-individual *population*)))
	((or 
	  (eq iterations 100000)
	  (eq (fitness best) 0))
	 (format t "~%Best: ~a~%Fitness: ~a~%Iterations: ~a~%Population size: ~a"
		 (genotype best)
		 (eval-fitness (genotype best)) iterations (length *population*)))
      (if (eq (mod (1+ iterations) 1000) 0) ;; prints a '.' every 1000 iterations
	  (format t ". "))
      (setf parents (tournament-selection))
      (setf children (1pointcrossover-permutation (first parents) (second parents)))
      (setf (first children) (swap-mutation-permutation (first children)))
      (setf (second children) (swap-mutation-permutation (second children)))
      (setf (first children) (make-instance 'individual
					    :genotype (first children)
					    :fitness (eval-fitness (first children))
					    :crossover `(,"1pointcrossover-permutation")
					    :mutation `(,"swap-mutation-permutation")))

      (setf (second children) (make-instance 'individual
					     :genotype (second children)
					     :fitness (eval-fitness (second children))
					     :crossover `(,"1pointcrossover-permutation")
					     :mutation `(,"swap-mutation-permutation")))
      (replacement (first children) (second children)))))

(defun initialize-population ()
  (setf *population* (permutations (range 0 *N*) *population-size*))
  ;; now go through and make each permuation into a real individual
  (do ( (individuals *population*  (rest individuals))
	(index 0 (1+ index)))
      ((null individuals) t)
    (setf (elt *population* index) 
	  (make-instance 'individual :genotype (first individuals)
			             :fitness (eval-fitness (first individuals))))))
    
    
(defun permutations (digits size)
  "Return a list of permutations of the input; Length dependent on size."
  ;; assuming a permutation of 8 digits...
  ;; if size = 1, 1 permuation created
  ;; if size = 2, 8 permuations
  ;; if size = 3, 56 permutations
  ;; if size = 4, 336 permuations
  ;; if size = 5, 1680 permuations
  ;; if size = 6, 6720 permuations

  ;; If the input is nil, there is only one permutation:
  ;; nil itself
  (if (null digits)
      '(())
      ;; Otherwise, take an element, e, out of the digits.
      ;; Generate all permutations of the remaining elements,
      ;; And add e to the front of each of these.
      ;; Do this for all possible e to generate all permutations.
        (if (> size 1)
	      (mapcan #'(lambda (e)
			  (mapcar #'(lambda (p) (cons e p))
				  (permutations
				   (remove e digits :count 1) (- size 1))))
		      digits)
	    (cons digits nil))))

(defun range (start end)
  "Utility function to generate a list of range start inclusive to end exclusive"
  (loop for i from start below end collect i))

(defun eval-fitness (individual)
  "Evalutes the fitness for the nqueens problem"
  ;; 8 queens along the diagonal means 56 conflicts ;
  ;; since each of the (8) queens conflicts with the other (7);
  ;; thus (8 * 7) is 56
  (let ( (conflicts 0) )
    (dotimes (i (length individual))
      (dotimes (j (length individual))
	(when (not (eq i j))
	  (if (eq (- (elt individual i) i) (- (elt individual j) j))
	      (setf conflicts (1+ conflicts)))
	  (if (eq (+ (elt individual i) i) (+ (elt individual j) j))
	      (setf conflicts (1+ conflicts))))))

    conflicts))

      
(defun tournament-selection (&key (k 5) (tournaments 2))
  "Chooses k individuals for a tournament and chooses the top two for parents"
  ;; Rank is based on the fitness and it is assumed the two best parents will be chosen
  (let ((mating-pool nil)
	(parents nil))
    (dotimes (round tournaments)
      (setf mating-pool nil)
      (dotimes (iteration k)
	(setf mating-pool (append mating-pool 
				 `(,(elt *population* (random (length *population*)))))))
      (setf parents (append parents 
			    `(,(first (sort-by-rank mating-pool :direction 'desc))))))
    parents))

(defun sort-by-rank (individuals &key (direction 'desc))
  "Sorts a list of individual and gives them a rank according to fitness"
  ;; :direction can be 'desc or 'asc; the default is desc
  (let ((result (individuals-quicksort individuals)))
    (do ( (z result (rest z))
	  (index 1 (1+ index)))
	((null z) result)
      ;; already sorted in desc, so just give it the proper rank in desc
      (setf (rank (first z)) (- (length individuals) index)))
    (if (eq direction 'desc)
	result
	(nreverse result))))

(defun individuals-quicksort (individuals)
  "Sorts the individuals numerically according to their fitness"
  ;; Since we minimize fitness, the individuals end up sorted in desc order
  (if (null individuals)
      nil
      (append
       (individuals-quicksort (individual< (first individuals) (rest individuals)))
       (cons (first individuals) nil)
       (individuals-quicksort (individual>= (first individuals) (rest individuals))))))

(defun individual< (e L)
  (if (null L)
      nil
      (if (< (fitness (first L)) (fitness e))
	  (cons (first L) (individual< e (rest L)))
	  (individual< e (rest L)))))

(defun individual>= (e L)
  (if (null L)
      nil
      (if (>= (fitness (first L)) (fitness e))
	  (cons (first L) (individual>= e (rest L)))
	  (individual>= e (rest L)))))

(defun 1pointcrossover-permutation (parent1 parent2)
  "Crosses over two genotypes (permuations) and uses 'cut-and-crossfill' method"
  ;; Returns a list of two children
  (let ((point (random (length (genotype parent1))))
	(child1 nil)
	(child2 nil))
    (when (eq point 0)
      (setf child1 (append `(,(first (genotype parent1)))
			   (crossfill `(,(first (genotype parent1)))
				      (rest (genotype parent2)) 
				      parent2)))
      (setf child2 (append `(,(first (genotype parent2))) 
			   (crossfill `(,(first (genotype parent2)))
				      (rest (genotype parent1))
				      parent1))))
     (when (> point 0)
       (dotimes (index point)
	 (setf child1 (append child1 (list (elt (genotype parent1) index))))
	 (setf child2 (append child2 (list (elt (genotype parent2) index)))))
       (setf child1 (append child1 
			    (crossfill child1 
				       (nthcdr point (genotype parent2)) 
				       parent2)))
       (setf child2 (append child2 
			    (crossfill child2
				       (nthcdr point (genotype parent1))
				       parent1))))
  `(,child1 ,child2)))

(defun order-crossover-permutation (parent1 parent2)
  "Order crossover for permutations; similar to PMX but less sophisticated"
  ;; Parents are real individuals while the children returned are only genotypes
  (let* ((point1 nil)
	 (point2 nil)
	 (points nil)
	 (temp nil)
	 (parent2-segment3 nil)
	 (child1 nil)
	 (child2 nil))
    ;; Keep genergating random number of if we get a 0 or the same number for both points
    (setf points 
	  (do ((r1 nil (random (length (genotype parent1))))
	       (r2 nil (random (length (genotype parent2)))))
	      ((and
		(and (not (eq 0 r1)) (not (eq 0 r2)))
		(not (eq r1 r2))) `(,r1 ,r2))))
    (setf point1 (first points))
    (setf point2 (second points))
    ;; Make sure point1 is less than point2; if not, swap
    (setf temp point1)
    (when (> point1 point2)
	(setf point1 point2)
	(setf point2 temp))
    (setf parent2-segment3 (nthcdr point2 (genotype parent2)))
    (dotimes (index point1)
      (setf child1 (append child1 
			   (list (elt (genotype parent2) index))))
      (setf child2 (append child2
			   (list (elt (genotype parent1) index)))))
    (dotimes (index (- point2 1))
      (setf child1 (append child1
			   (list (elt (genotype parent1) (+ index point1)))))
      (setf child2 (append child2
			   (list (elt (genotype parent2) (+ index point1))))))
    (setf child1 (append child1 (nthcdr point2 (genotype parent2))))
    (setf child2 (append child2 (nthcdr point2 (genotype parent1))))
    `(,child1 ,child2)))
    
(defun crossfill (child parent-segment parent)
  "Return list of genes to add to child skipping those genese which already exist"
  ;; parent-segment: genes from the "other" parent to form the last segment of the child
  ;; parent: full original "other" parent in case we need values before the crossover point
  ;; note we do not modify child, only use it to check the existence of genes
  (let ((result nil)
	(parent-index 0))
    (dolist (e parent-segment)
      (if (eq (count e child) 0) ;; child does not have gene
	  (setf result (append result (list e)))
	  (do ()
	      ((or (>= parent-index (length (genotype parent)))
		   (eq (length result) (length (genotype parent)))
		   ) t)
	    (if (eq (count (elt (genotype parent) parent-index)
				child) 0) ;; child does not have gene
		(progn 
		  (setf result (append result (list (elt (genotype parent) parent-index))))
		  (setf parent-index (1+ parent-index))
		  (return))
		(setf parent-index (1+ parent-index))))))
    result))

(defun swap-mutation-permutation (individual)
  "Returns an individual mutated by swapping two alleles"
  ;; The individual is a genotype and not the actual individual instance
  (let ((position1 (random (length individual)))
	(position2 (random (length individual)))
	(temp nil))
    (if (< *mutation-rate* (random 1.0))
	(return-from swap-mutation-permutation individual))
    (setf temp (elt individual position1))
    (setf (elt individual position1) (elt individual position2))
    (setf (elt individual position2) temp)
    individual))

(defun replacement (child1 child2)
  "Places child1 and child2 in the popluation killing off the two worst individuals"
  ;; Need to make sure they are no worse than the worse individuals
  ;; child1 and child2 are actual individuals and not genotypes
  (when (> (fitness child1) (fitness (worst-individual *population*)))
    (setf *population* (append *population* `(,child1)))
    (kill-worst))
  (when (> (fitness child2) (fitness (worst-individual *population*)))
    (setf *population* (append *population* `(,child2)))
    (kill-worst)))

;; Not used anymore since we want to allow takeover
(defun duplicate (individual)
  (dolist (p *population*)
	  (if (eq (genotype p) (genotype individual))
	      t))
  nil)
  
(defun worst-individual (group)
  (let ((worst (first group)))
    (dolist (g group)
      (if (> (fitness g) (fitness worst))
	  (setf worst g)))
    worst))

(defun best-individual (group)
  (let ((best (first group)))
    (dolist (g group)
      (if (< (fitness g) (fitness best))
	  (setf best g)))
    best))

(defun kill-worst ()
  (let ((worst (worst-individual *population*)))
    (setf *population* (remove worst *population*))))